home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / RXHOOK.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  13.8 KB  |  516 lines

  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit RxHook;
  12.  
  13. {$I RX.INC}
  14. {$T-,W-,X+,P+}
  15.  
  16. interface
  17.  
  18. uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  19.   Messages, SysUtils, Classes, Controls, Forms, RxConst;
  20.  
  21. type
  22.   PClass = ^TClass;
  23.   THookMessageEvent = procedure (Sender: TObject; var Msg: TMessage;
  24.     var Handled: Boolean) of object;
  25.  
  26.   TRxWindowHook = class(TComponent)
  27.   private
  28.     FActive: Boolean;
  29.     FControl: TWinControl;
  30.     FControlHook: TObject;
  31.     FBeforeMessage: THookMessageEvent;
  32.     FAfterMessage: THookMessageEvent;
  33.     function GetWinControl: TWinControl;
  34.     function GetHookHandle: HWnd;
  35.     procedure SetActive(Value: Boolean);
  36.     procedure SetWinControl(Value: TWinControl);
  37.     function IsForm: Boolean;
  38.     function NotIsForm: Boolean;
  39.     function DoUnhookControl: Pointer;
  40.     procedure ReadForm(Reader: TReader);
  41.     procedure WriteForm(Writer: TWriter);
  42.   protected
  43.     procedure DefineProperties(Filer: TFiler); override;
  44.     procedure DoAfterMessage(var Msg: TMessage; var Handled: Boolean); dynamic;
  45.     procedure DoBeforeMessage(var Msg: TMessage; var Handled: Boolean); dynamic;
  46.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  47.   public
  48.     constructor Create(AOwner: TComponent); override;
  49.     destructor Destroy; override;
  50.     procedure HookControl;
  51.     procedure UnhookControl;
  52.     property HookWindow: HWnd read GetHookHandle;
  53.   published
  54.     property Active: Boolean read FActive write SetActive default True;
  55.     property WinControl: TWinControl read GetWinControl write SetWinControl
  56.       stored NotIsForm;
  57.     property BeforeMessage: THookMessageEvent read FBeforeMessage write FBeforeMessage;
  58.     property AfterMessage: THookMessageEvent read FAfterMessage write FAfterMessage;
  59.   end;
  60.  
  61. function GetVirtualMethodAddress(AClass: TClass; AIndex: Integer): Pointer;
  62. function SetVirtualMethodAddress(AClass: TClass; AIndex: Integer;
  63.   NewAddress: Pointer): Pointer;
  64. function FindVirtualMethodIndex(AClass: TClass; MethodAddr: Pointer): Integer;
  65.  
  66. implementation
  67.  
  68. type
  69.   THack = class(TWinControl);
  70.   THookOrder = (hoBeforeMsg, hoAfterMsg);
  71. {$IFNDEF RX_D3}
  72.   TCustomForm = TForm;
  73. {$ENDIF}
  74.  
  75. { TControlHook }
  76.  
  77.   TControlHook = class(TObject)
  78.   private
  79.     FControl: TWinControl;
  80.     FNewWndProc: Pointer;
  81.     FPrevWndProc: Pointer;
  82.     FList: TList;
  83.     FDestroying: Boolean;
  84.     procedure SetWinControl(Value: TWinControl);
  85.     procedure HookWndProc(var AMsg: TMessage);
  86.     procedure NotifyHooks(Order: THookOrder; var Msg: TMessage;
  87.       var Handled: Boolean);
  88.   public
  89.     constructor Create;
  90.     destructor Destroy; override;
  91.     procedure HookControl;
  92.     procedure UnhookControl;
  93.     procedure AddHook(AHook: TRxWindowHook);
  94.     procedure RemoveHook(AHook: TRxWindowHook);
  95.     property WinControl: TWinControl read FControl write SetWinControl;
  96.   end;
  97.  
  98. { THookList }
  99.  
  100.   THookList = class(TList)
  101.   private
  102.     FHandle: HWnd;
  103.     procedure WndProc(var Msg: TMessage);
  104.   public
  105.     constructor Create;
  106.     destructor Destroy; override;
  107.     function FindControlHook(AControl: TWinControl): TControlHook;
  108.     function GetControlHook(AControl: TWinControl): TControlHook;
  109.     property Handle: HWnd read FHandle;
  110.   end;
  111.  
  112. var
  113.   HookList: THookList;
  114.  
  115. function GetHookList: THookList;
  116. begin
  117.   if HookList = nil then HookList := THookList.Create;
  118.   Result := HookList;
  119. end;
  120.  
  121. procedure DropHookList; far;
  122. begin
  123.   HookList.Free;
  124.   HookList := nil;
  125. end;
  126.  
  127. { TControlHook }
  128.  
  129. constructor TControlHook.Create;
  130. begin
  131.   inherited Create;
  132.   FList := TList.Create;
  133.   FNewWndProc := Classes.MakeObjectInstance(HookWndProc);
  134.   FPrevWndProc := nil;
  135.   FControl := nil;
  136. end;
  137.  
  138. destructor TControlHook.Destroy;
  139. begin
  140.   FDestroying := True;
  141.   if Assigned(HookList) then
  142.     if HookList.IndexOf(Self) >= 0 then HookList.Remove(Self);
  143.   while FList.Count > 0 do RemoveHook(TRxWindowHook(FList.Last));
  144.   FControl := nil;
  145.   FList.Free;
  146.   Classes.FreeObjectInstance(FNewWndProc);
  147.   FNewWndProc := nil;
  148.   inherited Destroy;
  149. end;
  150.  
  151. procedure TControlHook.AddHook(AHook: TRxWindowHook);
  152. begin
  153.   if FList.IndexOf(AHook) < 0 then begin
  154.     FList.Add(AHook);
  155.     AHook.FControlHook := Self;
  156.     WinControl := AHook.FControl;
  157.   end;
  158.   HookControl;
  159. end;
  160.  
  161. procedure TControlHook.RemoveHook(AHook: TRxWindowHook);
  162. begin
  163.   AHook.FControlHook := nil;
  164.   FList.Remove(AHook);
  165.   if FList.Count = 0 then UnhookControl;
  166. end;
  167.  
  168. procedure TControlHook.NotifyHooks(Order: THookOrder; var Msg: TMessage;
  169.   var Handled: Boolean);
  170. var
  171.   I: Integer;
  172. begin
  173.   if (FList.Count > 0) and Assigned(FControl) and
  174.     not (FDestroying or (csDestroying in FControl.ComponentState)) then
  175.     for I := FList.Count - 1 downto 0 do begin
  176.       try
  177.         if Order = hoBeforeMsg then
  178.           TRxWindowHook(FList[I]).DoBeforeMessage(Msg, Handled)
  179.         else if Order = hoAfterMsg then
  180.           TRxWindowHook(FList[I]).DoAfterMessage(Msg, Handled);
  181.       except
  182.         Application.HandleException(Self);
  183.       end;
  184.       if Handled then Break;
  185.     end;
  186. end;
  187.  
  188. procedure TControlHook.HookControl;
  189. var
  190.   P: Pointer;
  191. begin
  192.   if Assigned(FControl) and not ((csDesigning in FControl.ComponentState) or
  193.     (csDestroying in FControl.ComponentState) or FDestroying) then
  194.   begin
  195.     FControl.HandleNeeded;
  196.     P := Pointer(GetWindowLong(FControl.Handle, GWL_WNDPROC));
  197.     if (P <> FNewWndProc) then begin
  198.       FPrevWndProc := P;
  199.       SetWindowLong(FControl.Handle, GWL_WNDPROC, LongInt(FNewWndProc));
  200.     end;
  201.   end;
  202. end;
  203.  
  204. procedure TControlHook.UnhookControl;
  205. begin
  206.   if Assigned(FControl) then begin
  207.     if Assigned(FPrevWndProc) and FControl.HandleAllocated and
  208.     (Pointer(GetWindowLong(FControl.Handle, GWL_WNDPROC)) = FNewWndProc) then
  209.       SetWindowLong(FControl.Handle, GWL_WNDPROC, LongInt(FPrevWndProc));
  210.   end;
  211.   FPrevWndProc := nil;
  212. end;
  213.  
  214. procedure TControlHook.HookWndProc(var AMsg: TMessage);
  215. var
  216.   Handled: Boolean;
  217. begin
  218.   Handled := False;
  219.   if Assigned(FControl) then begin
  220.     if (AMsg.Msg <> WM_QUIT) then NotifyHooks(hoBeforeMsg, AMsg, Handled);
  221.     with AMsg do begin
  222.       if (not Handled) or (Msg = WM_DESTROY) then
  223.         try
  224.           if Assigned(FPrevWndProc) then
  225.             Result := CallWindowProc(FPrevWndProc, FControl.Handle, Msg,
  226.               WParam, LParam)
  227.           else
  228.             Result := CallWindowProc(THack(FControl).DefWndProc,
  229.               FControl.Handle, Msg, WParam, LParam);
  230.         finally
  231.           NotifyHooks(hoAfterMsg, AMsg, Handled);
  232.         end;
  233.       if Msg = WM_DESTROY then begin
  234.         UnhookControl;
  235.         if Assigned(HookList) and not (FDestroying or
  236.           (csDestroying in FControl.ComponentState)) then
  237.           PostMessage(HookList.FHandle, CM_RECREATEWINDOW, 0, Longint(Self));
  238.       end;
  239.     end;
  240.   end;
  241. end;
  242.  
  243. procedure TControlHook.SetWinControl(Value: TWinControl);
  244. begin
  245.   if Value <> FControl then begin
  246.     UnhookControl;
  247.     FControl := Value;
  248.     if FList.Count > 0 then HookControl;
  249.   end;
  250. end;
  251.  
  252. { THookList }
  253.  
  254. constructor THookList.Create;
  255. begin
  256.   inherited Create;
  257.   FHandle := Classes.AllocateHWnd(WndProc);
  258. end;
  259.  
  260. destructor THookList.Destroy;
  261. begin
  262.   while Count > 0 do TControlHook(Last).Free;
  263.   Classes.DeallocateHWnd(FHandle);
  264.   inherited Destroy;
  265. end;
  266.  
  267. procedure THookList.WndProc(var Msg: TMessage);
  268. var
  269.   Hook: TControlHook;
  270. begin
  271.   try
  272.     with Msg do begin
  273.       if Msg = CM_RECREATEWINDOW then begin
  274.         Hook := TControlHook(LParam);
  275.         if (Hook <> nil) and (IndexOf(Hook) >= 0) then
  276.           Hook.HookControl;
  277.       end
  278.       else if Msg = CM_DESTROYHOOK then begin
  279.         Hook := TControlHook(LParam);
  280.         if Assigned(Hook) and (IndexOf(Hook) >= 0) and
  281.           (Hook.FList.Count = 0) then Hook.Free;
  282.       end
  283.       else Result := DefWindowProc(FHandle, Msg, wParam, lParam);
  284.     end;
  285.   except
  286.     Application.HandleException(Self);
  287.   end;
  288. end;
  289.  
  290. function THookList.FindControlHook(AControl: TWinControl): TControlHook;
  291. var
  292.   I: Integer;
  293. begin
  294.   if Assigned(AControl) then
  295.     for I := 0 to Count - 1 do
  296.       if (TControlHook(Items[I]).WinControl = AControl) then begin
  297.         Result := TControlHook(Items[I]);
  298.         Exit;
  299.       end;
  300.   Result := nil;
  301. end;
  302.  
  303. function THookList.GetControlHook(AControl: TWinControl): TControlHook;
  304. begin
  305.   Result := FindControlHook(AControl);
  306.   if Result = nil then begin
  307.     Result := TControlHook.Create;
  308.     try
  309.       Add(Result);
  310.       Result.WinControl := AControl;
  311.     except
  312.       Result.Free;
  313.       raise;
  314.     end;
  315.   end;
  316. end;
  317.  
  318. { TRxWindowHook }
  319.  
  320. constructor TRxWindowHook.Create(AOwner: TComponent);
  321. begin
  322.   inherited Create(AOwner);
  323.   FActive := True;
  324. end;
  325.  
  326. destructor TRxWindowHook.Destroy;
  327. begin
  328.   Active := False;
  329.   WinControl := nil;
  330.   inherited Destroy;
  331. end;
  332.  
  333. procedure TRxWindowHook.SetActive(Value: Boolean);
  334. begin
  335.   if FActive <> Value then
  336.     if Value then HookControl else UnhookControl;
  337. end;
  338.  
  339. function TRxWindowHook.GetHookHandle: HWnd;
  340. begin
  341.   if Assigned(HookList) then Result := HookList.Handle
  342.   else
  343. {$IFDEF WIN32}
  344.     Result := INVALID_HANDLE_VALUE;
  345. {$ELSE}
  346.     Result := 0;
  347. {$ENDIF}
  348. end;
  349.  
  350. procedure TRxWindowHook.HookControl;
  351. begin
  352.   if Assigned(FControl) and not (csDestroying in ComponentState) then
  353.     GetHookList.GetControlHook(FControl).AddHook(Self);
  354.   FActive := True;
  355. end;
  356.  
  357. function TRxWindowHook.DoUnhookControl: Pointer;
  358. begin
  359.   Result := FControlHook;
  360.   if Result <> nil then TControlHook(Result).RemoveHook(Self);
  361.   FActive := False;
  362. end;
  363.  
  364. procedure TRxWindowHook.UnhookControl;
  365. begin
  366.   DoUnhookControl;
  367.   FActive := False;
  368. end;
  369.  
  370. function TRxWindowHook.NotIsForm: Boolean;
  371. begin
  372.   Result := (WinControl <> nil) and not (WinControl is TCustomForm);
  373. end;
  374.  
  375. function TRxWindowHook.IsForm: Boolean;
  376. begin
  377.   Result := (WinControl <> nil) and ((WinControl = Owner) and
  378.     (Owner is TCustomForm));
  379. end;
  380.  
  381. procedure TRxWindowHook.ReadForm(Reader: TReader);
  382. begin
  383.   if Reader.ReadBoolean then
  384.     if Owner is TCustomForm then WinControl := TWinControl(Owner);
  385. end;
  386.  
  387. procedure TRxWindowHook.WriteForm(Writer: TWriter);
  388. begin
  389.   Writer.WriteBoolean(IsForm);
  390. end;
  391.  
  392. procedure TRxWindowHook.DefineProperties(Filer: TFiler);
  393. {$IFDEF WIN32}
  394.   function DoWrite: Boolean;
  395.   begin
  396.     if Assigned(Filer.Ancestor) then
  397.       Result := IsForm <> TRxWindowHook(Filer.Ancestor).IsForm
  398.     else Result := IsForm;
  399.   end;
  400. {$ENDIF}
  401. begin
  402.   inherited DefineProperties(Filer);
  403.   Filer.DefineProperty('IsForm', ReadForm, WriteForm,
  404.     {$IFDEF WIN32} DoWrite {$ELSE} IsForm {$ENDIF});
  405. end;
  406.  
  407. function TRxWindowHook.GetWinControl: TWinControl;
  408. begin
  409.   if Assigned(FControlHook) then Result := TControlHook(FControlHook).WinControl
  410.   else Result := FControl;
  411. end;
  412.  
  413. procedure TRxWindowHook.DoAfterMessage(var Msg: TMessage; var Handled: Boolean);
  414. begin
  415.   if Assigned(FAfterMessage) then FAfterMessage(Self, Msg, Handled);
  416. end;
  417.  
  418. procedure TRxWindowHook.DoBeforeMessage(var Msg: TMessage; var Handled: Boolean);
  419. begin
  420.   if Assigned(FBeforeMessage) then FBeforeMessage(Self, Msg, Handled);
  421. end;
  422.  
  423. procedure TRxWindowHook.Notification(AComponent: TComponent; Operation: TOperation);
  424. begin
  425.   inherited Notification(AComponent, Operation);
  426.   if (AComponent = WinControl) and (Operation = opRemove) then
  427.     WinControl := nil
  428.   else if (Operation = opRemove) and ((Owner = AComponent) or
  429.     (Owner = nil)) then WinControl := nil;
  430. end;
  431.  
  432. procedure TRxWindowHook.SetWinControl(Value: TWinControl);
  433. var
  434.   SaveActive: Boolean;
  435.   Hook: TControlHook;
  436. begin
  437.   if Value <> WinControl then begin
  438.     SaveActive := FActive;
  439.     Hook := TControlHook(DoUnhookControl);
  440.     FControl := Value;
  441. {$IFDEF WIN32}
  442.     if Value <> nil then Value.FreeNotification(Self);
  443. {$ENDIF}
  444.     if Assigned(Hook) and (Hook.FList.Count = 0) and Assigned(HookList) then
  445.       PostMessage(HookList.Handle, CM_DESTROYHOOK, 0, Longint(Hook));
  446.     if SaveActive then HookControl;
  447.   end;
  448. end;
  449.  
  450. { SetVirtualMethodAddress procedure. Destroy destructor has index 0,
  451.   first user defined virtual method has index 1. }
  452.  
  453. type
  454.   PPointer = ^Pointer;
  455.  
  456. function GetVirtualMethodAddress(AClass: TClass; AIndex: Integer): Pointer;
  457. var
  458.   Table: PPointer;
  459. begin
  460.   Table := PPointer(AClass);
  461.   Inc(Table, AIndex - 1);
  462.   Result := Table^;
  463. end;
  464.  
  465. function SetVirtualMethodAddress(AClass: TClass; AIndex: Integer;
  466.   NewAddress: Pointer): Pointer;
  467. {$IFDEF WIN32}
  468. const
  469.   PageSize = SizeOf(Pointer);
  470. {$ENDIF}
  471. var
  472.   Table: PPointer;
  473. {$IFDEF WIN32}
  474.   SaveFlag: DWORD;
  475. {$ELSE}
  476.   Block: Pointer;
  477. {$ENDIF}
  478. begin
  479.   Table := PPointer(AClass);
  480.   Inc(Table, AIndex - 1);
  481.   Result := Table^;
  482. {$IFDEF WIN32}
  483.   if VirtualProtect(Table, PageSize, PAGE_EXECUTE_READWRITE, @SaveFlag) then
  484.   try
  485.     Table^ := NewAddress;
  486.   finally
  487.     VirtualProtect(Table, PageSize, SaveFlag, @SaveFlag);
  488.   end;
  489. {$ELSE}
  490.   PtrRec(Block).Ofs := PtrRec(Table).Ofs;
  491.   PtrRec(Block).Seg := AllocCSToDSAlias(PtrRec(Table).Seg);
  492.   try
  493.     PPointer(Block)^ := NewAddress;
  494.   finally
  495.     FreeSelector(PtrRec(Block).Seg);
  496.   end;
  497. {$ENDIF}
  498. end;
  499.  
  500. function FindVirtualMethodIndex(AClass: TClass; MethodAddr: Pointer): Integer;
  501. begin
  502.   Result := 0;
  503.   repeat
  504.     Inc(Result);
  505.   until (GetVirtualMethodAddress(AClass, Result) = MethodAddr);
  506. end;
  507.  
  508. initialization
  509.   HookList := nil;
  510. {$IFDEF WIN32}
  511. finalization
  512.   DropHookList;
  513. {$ELSE}
  514.   AddExitProc(DropHookList);
  515. {$ENDIF}
  516. end.